Fifty: Elektronik/FIFTY Elektronik (PS_Computer_Vertrieb).iso/ps8/fty1017/gepackt.exe/DISK2/PLOTSRC.EXE/PLOTSYS.INC

Text File | 1993-11-10 | 13.4 KB | 586 lines

Procedure ErrorInit;
Begin
  GotoXY(1,25);ClrEol;Beep;
End;

Const  FehlerCode :Integer=0;

procedure error(ErrCode:integer);
Begin
   FehlerCode:=ErrCode;
   Halt(ErrCode+100);
End;

procedure errorMSG;
Begin
  If FehlerCode<>0 then
  begin
    Writeln;
    Writeln;
    Case Fehlercode Of
      3 : With SetupInfo do
           Write('Zeichensatz ',Zeichensatz1,' und ',Zeichensatz2,' nicht gefunden');
      6 : Write('nicht genug Speicher');
      7 : Write('Schwerer Disk-Fehler');
      9 : Write('GED.INF nicht gefunden');
      11: Write('GED.FIL nicht gefunden ');
      12: Write('Programmpfad ungültig');
      13: Write('Zeichnungs-/Macro-Pfad ungültig');
      100:Write('Ungültige Parameter');
      101:Write('Plotformat nicht gefunden');
      102:Write('MACRO nicht gefunden');
      103:Write('Zeichnung nicht gefunden');
      104:Write('Datei-Zugriffsfehler');
      110:Write('interner Fehler in ID-Tabelle');
        Else Write('Unbekannter Fehler');
    End;
    Writeln;
    If Not(Batch) then
     begin
       Writeln('Weiter : Irgendeine Taste !');
       WaitonKey;
     end;
   end;
End;

Procedure Normalize(Var Phi :Integer);
begin
  Phi:=Phi mod 360;
  If Phi <0 Then Inc(Phi,360);
end;


Procedure SinusCosinus(Phi :integer; Var Si,Co :Real);
(*Bestimmt Sinus und Cosinus aus Tabelle, Phi in ganzen Grad*)

Begin
  Normalize(Phi);
  If Phi<90 Then
    Begin
      Co:=GrSinus[90-Phi];
      Si:=GrSinus[Phi];
     End
  Else
    If Phi<180 Then
      Begin
        Co:=-GrSinus[Phi-90];
        Si:=GrSinus[180-Phi];
      End
    Else
      If Phi<270 Then
        Begin
          Co:=-GrSinus[270-Phi];
          Si:=-GrSinus[Phi-180];
         End
      Else
         Begin
          Co:=GrSinus[Phi-270];
          Si:=-GrSinus[360-Phi];
        End;
End;


Procedure CircleCoord(RX,RY,Phi :Integer  ;Var CX,CY :Real);
(*bestimmt PolarKoord. auf einer Ellipse (RX,RY) *)

Var Si,Co       :Real;
Begin
  SinusCosinus(Phi,Si,Co);
  CX:=RX*Co;
  CY:=RY*Si;
End;


Procedure Turnto(Phi :Integer);
(*Initialisiert Drehmatrix gemäß Phi *)

Var Si,Co   :Real;
Begin
  Normalize(Phi);
  If Not(Phi=GrRotPhi) Then
  Begin
    SinusCosinus(Phi,Si,Co);
    GrRotPhi:= Phi;
    GrRot11:=Co;GrRot22:=GrRot11;
    GrRot21:=Si;GrRot12:=-GrRot21;
  End;
End;


Procedure Rotreal(Var X,Y :Real);
(*Rotiert X,Y um durch Turnto festgelegten Winkel Phi *)

Var Xneu,Yneu :Real;
Begin
  Case GrRotPhi Of
    0,360 : Begin
             Xneu:=X;
             Yneu:=Y;
           End;
    90   : Begin
             Xneu:=-Y;
             Yneu:=X;
           End;
    180  : Begin
             Xneu:=-X;
             Yneu:=-Y;
           End;
    270  : Begin
             Xneu:=Y;
             Yneu:=-X;
           End;
    Else
         Begin
           Xneu:=GrRot11*X+GrRot12*Y;
           Yneu:=GrRot21*X+GrRot22*Y;
         End;
  End;
  X:=Xneu;
  Y:=Yneu;
End;


Procedure Rotate(Var X,Y :Integer);

Var Xneu,Yneu :Integer;
(*Rotiert X,Y um durch Turnto festgelegten Winkel Phi *)
Begin
  Case GrRotPhi Of
    0,360 : Begin
             Xneu:=X;
             Yneu:=Y;
           End;
    90   : Begin
             Xneu:=-Y;
             Yneu:=X;
           End;
    180  : Begin
             Xneu:=-X;
             Yneu:=-Y;
           End;
    270  : Begin
             Xneu:=Y;
             Yneu:=-X;
           End;
    Else
         Begin
           Xneu:=RealToInt(GrRot11*X+GrRot12*Y);
           Yneu:=RealToInt(GrRot21*X+GrRot22*Y);
         End;
  End;
  X:=Xneu;
  Y:=Yneu;
End;


Function PlotKoord(X:Real):Real;
(*Bestimmt Potterkoordinate aus Zeichnungskoordinate in mm*)

begin
  PlotKoord:=X*InvPlotRes;
end;


Function Ungleich(A,B:Real):Boolean;
(*Prüft Gleichheit zweier Zeichnungskoordinaten*)

begin
  Ungleich:=Abs(A-B)>=PlotRes;
end;


Function PlotLimit(X:Real):Real;
(*Begrenzt Maß auf >= Plotterauflösung*)

begin
  If X<PlotRes Then
    PlotLimit:=PlotRes
  else
    PlotLimit:=X;
end;



Function CalcPhi(X,Y :Real):Integer;
(*bestimmt Winkel aus X,Y (arctan) *)

Var Phi:Integer;
  Begin
    If (X=0) and (Y=0) Then
      Phi:=0
    Else
    If X=0 Then
      If Y>0 Then Phi:=90 Else Phi:=-90
    Else
     Phi:=RealToInt(ArcTan(Y/X)*180/Pi);
    If X<0 Then Phi:=180+Phi
      Else Normalize(Phi);
    CalcPhi:=Phi;
  End;


Procedure GrafWindow(X1,Y1,X2,Y2 :Integer);
(* legt Plotterausgabefenster fest *)

Var ExChange  :Integer;
Begin
  With SetupInfo.SetUpPlotter do
  begin
    If X1>X2  Then Begin Exchange:=X2;X2:=X1;X1:=Exchange; End;
    If X1<MinFormX Then X1:=MinFormX;
    If X2>FormX Then X2:=FormX;
    If Y1>Y2  Then Begin Exchange:=Y2;Y2:=Y1;Y1:=Exchange; End;
    If Y1<MinFormY  Then Y1:=MinFormY;
    If Y2>FormY Then Y2:=FormY;
  end;
  GrWindowX1:=PlotKoord(X1);GrWindowX2:=PlotKoord(X2);
  GrWindowY1:=PlotKoord(Y1);GrWindowY2:=PlotKoord(Y2);
End;



Procedure WhichField(X,Y :Real;Var WoX,WoY :Integer);
(* wird für Clip-Funktion (Randabschneiden) benötigt  *)

Begin
  WoX:=0;WoY:=0;
  If X>GrWindowX2 Then WoX:=1;
  If X<GrWindowX1 Then WoX:=-1;
  If Y>GrWindowY2 Then WoY:=1;
  If Y<GrWindowY1 Then WoY:=-1;
End;


Function InWindow(X,Y :Real) :Boolean;
(* Prüft ob Punkt im Ausgabe-Fenster *)

Begin
   Inwindow:=false;
   If (X>=GrWindowX1) then
     If (X<=GrWindowX2) then
       If (Y<=GrWindowY2) then
         If (Y>=GrWindowY1) then Inwindow:=true;
End;



Function Clip(Var X1,Y1,X2,Y2: Real ):Boolean;
(* schneidet Gerade X1,Y1,X2,Y2 an den Rändern des Ausgabefensters ab *)
(* oder meldet wenn Gerade nicht gezeichnet werden muß (Clip=false )  *)

Var X1d,X2d,Y1d,Y2d,CutX,CutY :Real;
    WoX1,WoY1,WoX2,WoY2 :Integer;
Begin
  X1d:=X1;X2d:=X2;
  Y1d:=Y1;Y2d:=Y2;{Annahme Punkte im Fenster}
  WhichField(X1d,Y1d,WoX1,WoY1);
  WhichField(X2d,Y2d,WoX2,WoY2);
  If ((WoX1=WoX2) and (WoX1<>0)) or ((WoY1=WoY2) and (WoY1<>0))
    Then {Beide Punkte auf der selben Seite ausserhalb}
      Clip:=false
  Else
   Begin
    If WoX1<>0 Then {Punkt1 ausserhalb X-Seite}
      Begin
        If WoX1=1  Then CutX:=GrwindowX2;
        If WoX1=-1 Then CutX:=GrWindowX1;
        Y1d:=Y1d+(Y2-Y1)/(X2-X1)*(CutX-X1d);
        X1d:=CutX;
        WhichField(X1d,Y1d,WoX1,WoY1);
      End;
    If WoY1<>0 Then {Punkt 1 ausserhalb Y-Seite}
      Begin
        If WoY1=1  Then CutY:=GrwindowY2;
        If WoY1=-1 Then CutY:=GrWindowY1;
        X1d:=X1d+(X2-X1)/(Y2-Y1)*(CutY-Y1d);
        Y1d:=CutY;
        WhichField(X1d,Y1d,WoX1,WoY1);
      End;
    If WoX2<>0 Then {Punkt2 ausserhalb X-Seite}
      Begin
        If WoX2=1  Then CutX:=GrwindowX2;
        If WoX2=-1 Then CutX:=GrWindowX1;
        Y2d:=Y1d+(Y2-Y1)/(X2-X1)*(CutX-X1d);
        X2d:=CutX;
        WhichField(X2d,Y2d,WoX2,WoY2);
      End;
    If WoY2<>0 Then {Punkt 2 ausserhalb Y-Seite}
      Begin
        If WoY2=1  Then CutY:=GrwindowY2;
        If WoY2=-1 Then CutY:=GrWindowY1;
        X2d:=X1d+(X2-X1)/(Y2-Y1)*(CutY-Y1d);
        Y2d:=CutY;
        WhichField(X2d,Y2d,WoX2,WoY2);
      End;
    Clip:=(WoX1 or WoY1 or WoX2 or WoY2)=0;
    X1:=X1d;X2:=X2d;
    Y1:=Y1d;Y2:=Y2d;
   End;
End;

Procedure  FreeChMem(Var Index :ChIPtr;Var Chars :ChFPtr);
begin
  If Index<>nil then
    begin
      FreeMem(Chars,ChInfo(index^).Size);
      Dispose(Index);
      Index:=nil;
      Chars:=nil;
    end;
end;

Procedure GetCharsetNames(BildDatei :PathStr);
Const NrtoRead=25;  { ca. 1K }
Var F:File;
    BldBuffer:Array[1..NrToRead] of Bildelement;
    FileVersion,
    Dummy,Nread:Word;
    Count,I    :Word;
begin
  {$I-}
  Assign(F,BildDatei);
  Reset(F,Sizeof(Bildelement));
  If IoResult=0 then
    begin
      BlockRead(F,BldBuffer,NrtoRead,Nread);
      If (IoResult=0) and (Nread>5) then
       begin
         FileVersion:=Defaults(BldBuffer[1]).GEDVersion and $7FF;
         If FileVersion>VersionCode+$10 then FileVersion:=0;
         { Datei wesentlich neuer als Zeichnungseditor muß Schmarrn sein !}
         SetOldGeddyVersion(FileVersion<$0510);
         If FileVersion>=$0510 then
         begin
           Count:=0;
           For I:=2  to Nread do
             With Ed_InfoTyp(BldBuffer[I]) do
               begin
                 If ElementTyp=ED_Info then
                   if Typ=FontInfo then
                     if Count<2 then
                       begin
                         Inc(Count);
                         If FileExists(SearchFile(FontName)) then
                          begin
                            Case Count of
                              1:SetupInfo.Zeichensatz1:=FontName;
                              2:SetupInfo.Zeichensatz2:=FontName;
                            end; { Case }
                          end; {If FileExists }
                       end; { If }
               end; { With }
         end; { If FileVersion }
       end; { Ioresult = 0  }
    end;
  close(F);
  Dummy:=Ioresult;
  {$i+}
end;

Procedure  FreeCharMem;
begin
  If CharIndex1=Charindex2  then
     CharIndex2:=nil;
  FreeChMem(CharIndex2,GrafSet2);
  FreeChMem(CharIndex1,GrafSet1);
end;

Procedure GetIndex(Var Index :Chindex;Var Chars :Chfeld);
  Var I,Start:Integer;
  begin
    Start:=0;
    For I:=0 to 223 do
    begin
      Index[I]:=Start;
      Start:=Start+Chars[Start].CharY;
    end;
  end;

Function Zeichensatz_lesen(Var Index :ChIPtr;Var Chars :ChFPtr;
                             ChName :Str15):Word;
{ 0= Ok, 1 = File Not Found , 2 = No Memory, 3 Anderer Fehler }
  Var Fil       :File;
      BufSize,N,
      Nread,I   :Word;
      Ok        :Word;
Begin
  Zeichensatz_lesen:=1;
  If ChName<>'' then
  begin
    Assign(Fil,SearchFile(ChName));
    (*$I-*)
    Reset(fil,1);
    If IOResult=0 Then
      Begin
        Ok:=0;
        N:=FileSize(Fil);
        If Ioresult<>0 then
          Ok:=1;
        BufSize:=N;
        Index:=nil;
        If MaxAvail>BufSize+Sizeof(ChIndex) then
          begin
            GetMem(Chars,Bufsize);
            New(Index);
            ChInfo(Index^).Size:=BufSize;
          end else Ok:=2;
        If Ok=0 then
          begin
            BlockRead(fil,Chars^,N,Nread);
            If (Ioresult<>0) or (N<>Nread) then Ok:=1;
            GetIndex(Index^,Chars^);
          end;
        Close(fil);
        I:=Ioresult;
        (*$I+*)
        If (Ok<>0) and (Index<>nil) then
          begin
            Dispose(Index);
            FreeMem(Chars,BufSize);
            Chars:=nil;
            Index:=nil;
          end;
        Zeichensatz_lesen:=Ok;
      end; {Ioresult=0}
  End; {ChName<>''}
end;

Function CharSetInit:Word;
Var R1,R2 :Integer;
 { Result =0 :Fehler;
   Result =1 :Z-Satz1 Ok
   Result =2 :Z-Satz2 Ok
   Result =3 :Z-Satz1 + Z-Satz2 Ok }

begin
  GrafSet1:=nil;
  Grafset2:=nil;
  CharIndex1:=nil;
  CharIndex2:=nil;
  CharsetInit:=0;;
  R1:=Zeichensatz_lesen(CharIndex1,Grafset1,SetupInfo.Zeichensatz1);
  R2:=Zeichensatz_lesen(CharIndex2,Grafset2,SetupInfo.Zeichensatz2);
  If (R1=0) and (R2<>0) then
    begin
      CharIndex2:=CharIndex1;
      Grafset2:=Grafset1;
      CharsetInit:=1;
    end;
  If (R1<>0) and (R2=0) then
    begin
      CharIndex1:=CharIndex2;
      Grafset1:=Grafset2;
      CharsetInit:=2;
    end;
  If (R1=0) and (R2=0) then
      CharsetInit:=3;
end;

Procedure ReInitCharset;
begin
  SetupInfo.Zeichensatz2:=Setupinfo.Zeichensatz4;
  SetupInfo.Zeichensatz1:=Setupinfo.Zeichensatz3;
  FreeCharMem;
  If CharsetInit=0 then Error(3);
end;



procedure PlotSysInit;

var i:integer;
begin
    GotoXY(1,1);
    For i:=0 to 90 Do  (* Initialisierung der Sinustabelle *)
      GrSinus[i]:=Sin(Pi/180*i);
    Turnto(0);
    If CharsetInit=0 then Error(3);
    If Maxavail<32768 then Error(6);
    Auto_ClrInp:=Not(SetupInfo.Input_NoClear);
end;

Procedure  LoadSetup;
Var SetupFile  :File of Setup;
    I,Col :Integer;
begin
  assign(Setupfile,SetupF);
  {$I-} reset(SetupFile); {$I+}
  if IOResult=0 then
    begin
      read(SetupFile,Setupinfo);
      close(Setupfile);
    end
     else Error(9);
  With SetupInfo.SetUpPlotter do
  begin
    If FormX<0 Then MinFormX:=FormX else MinFormX:=0;
    FormX:=Abs(FormX);
    If FormY<0 Then MinFormY:=FormY else MinFormY:=0;
    FormY:=Abs(FormY);
  end;
end;

Procedure  LoadFileSetup;
Var SetupFile  :File of FileInf;
begin
  assign(Setupfile,FSetupF);
  {$I-} reset(SetupFile); {$I+}
  if IOResult=0 then
    begin
      read(SetupFile,FileSetup);
      close(Setupfile);
    end
     else Error(11);
end;

Procedure  CheckPath(Var P :PathStr);
  begin
    if Not PathExists(P) then
        Error(13);
  end;

Procedure CheckDirs;
Begin
  With FileSetup Do
  Begin
    Activepath:=DWGPath;
    Macropath:=LibPath;
    CheckPath(ActivePath);
    CheckPath(MacroPath);
    DirMask:='*.*';
   End;
End;

procedure NormVideo;
  begin
    If ModeCO80 then Crt.TextColor(Crt.Yellow)
    else
      Crt.TextColor(Crt.White);
  end;

procedure LowVideo;
  begin
    If ModeCO80 then Crt.TextColor(Crt.Cyan)
    else
      Crt.TextColor(Crt.Lightgray);
  end;

Procedure InitCharNames;
Var Pa  :PathStr;
    Na  :NameStr;
    Ex  :ExtStr;
begin
  If Batch then
    begin
      Fsplit(ParamStr(1),Pa,Na,Ex);
      Pa:=Pa+Na+Dsuf;
    end
  else
   begin
     Pa:=Filesetup.DWG+Dsuf;
     ProcessFilename(Filesetup.DWGPath,Pa);
   end;
  GetCharsetNames(Pa);
end;